home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / COMP.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  20.7 KB  |  584 lines
  1. ; COMP.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Compiler Specific Runtime Routines            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Terry Caudill        Date: Jun 1985            *
  16. ;* Revision history:                            *
  17. ;* - 1 Jun 87:    Added PCS-INTEGRATE-DEFINE variable so that MIT style    *
  18. ;*        defines don-t expand into named/lambda unless #T. This    *
  19. ;*        is a requirement for R^3 Report. (tc)            *
  20. ;*        Added STRING->NUMBER & MAKE/STRING as autoload. (tc)    *
  21. ;*        Make compiler Re-entrant. (tc)                *
  22. ;*        RESET does'nt affect INPUT/OUTPUT-PORT so the system    *
  23. ;*        might run in windows other than 'CONSOLE. (rb)        *
  24. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  25. ;* - 20 Aug 92:    Added support for inline coding (inline-lambda)    (lb)    *
  26. ;* - 25 Dec 92: Added Scheme-web support (mv)                *
  27. ;*                                    *
  28. ;*                    ``In nomine omnipotentii dei''    *
  29. ;************************************************************************
  30.  
  31. ;
  32. ; The following functions are related in that they all envoke the
  33. ; compiler in some form or fashion
  34. ;
  35. (define load                        ; LOAD
  36.        (lambda (filename)
  37.      (let ((read (if (string-ci=? (cadddr (filename-split filename)) ".sw")
  38.                  read-sw read))
  39.            (i-port (open-input-file filename)))
  40.            (if (null? i-port)
  41.                (error "Unable to load file" filename)
  42.                (letrec
  43.                  ((loop
  44.                     (lambda (form)
  45.                       (cond ((eof-object? form)
  46.                              (close-input-port i-port)
  47.                              'ok)
  48.                             (else
  49.                               (eval form)
  50.                               (loop (read i-port)))))))
  51.                  (let ((form (read i-port)))
  52.                    (if (eq? form '#!fast-load)
  53.                        (begin
  54.                          (close-input-port i-port)
  55.                          (fast-load filename))
  56.                        (loop form))))))))
  57.  
  58. (define compile-file                    ; COMPILE-FILE
  59.        (lambda (filename1 filename2)
  60.      (if (or (not (string? filename1))
  61.          (not (string? filename2))
  62.          (equal? filename1 filename2))
  63.          (%error-invalid-operand-list 'COMPILE-FILE
  64.             filename1
  65.             filename2)
  66.          (let ((read (if (string-ci=? (cadddr (filename-split filename1)) ".sw")
  67.                  read-sw read))
  68.            (i-port (open-input-file filename1)))
  69.            (let ((o-port (open-output-file filename2)))
  70.          (set-line-length! 74 o-port)
  71.          (letrec
  72.            ((loop
  73.             (lambda (form)
  74.               (if (eof-object? form)
  75.                   (begin (close-input-port i-port)
  76.                      (close-output-port o-port)
  77.                      'ok)
  78.                   (begin            ; no COMPILE-FORMS
  79.                  (compile-to-file form)
  80.                  (set! form '())     ; for GC
  81.                  (loop (read i-port))))))
  82.             (compile-to-file
  83.             (lambda (form)
  84.               (let ((cform (compile form)))
  85.                 (write (list '%execute (list 'quote cform))
  86.                    o-port)
  87.                 (newline o-port)
  88.                 (%execute cform)))))
  89.          (loop (read i-port))))))))
  90.  
  91. (define %compile-timings '())
  92.  
  93. (define %compile                    ; %COMPILE
  94.   (lambda (exp . time?)
  95.     (when time? (gc))
  96.     (let ((time '())
  97.           (t0 (clock)))
  98.       (set! pcs-local-var-count 0)
  99.       (set! pcs-error-flag #F)
  100.       (set! pcs-verbose-flag (not time?))
  101.       (set! pcs-binary-output #F)
  102.       (set! pme= (pcs-macro-expand exp))
  103.       (if pcs-error-flag
  104.           (error "[Compilation terminated because of errors]")
  105.           (begin
  106.             (set! time (cons (- (clock) t0) time))
  107.             (set! psimp= (pcs-simplify pme=))
  108.             (set! time (cons (- (clock) t0) time))
  109.             (pcs-closure-analysis psimp=)
  110.             (set! time (cons (- (clock) t0) time))
  111.             (set! pcg= (pcs-gencode psimp=))
  112.             (set! time (cons (- (clock) t0) time))
  113.             (set! ppeep= (pcs-postgen pcg=))
  114.             (set! time (cons (- (clock) t0) time))
  115.             (set! pasm= (pcs-assembler ppeep=))
  116.             (set! time (cons (- (clock) t0) time))
  117.             (set! pcs-verbose-flag #F)
  118.             (when time?
  119.                   (set! %compile-timings
  120.                         (cons (%reverse! time) %compile-timings)))
  121.             pasm=)))))
  122.  
  123. ;
  124. ; Make compiler re-entrant (or more so, at any rate). The problem arises
  125. ; when a macro evokes EVAL and thus COMPILE during macro expansion i9n PME
  126. ;
  127. (define compile)                                        ; COMPILE
  128.  
  129. (let ((ge (%set-global-environment user-global-environment)))
  130.       (set! compile
  131.     (lambda (exp)
  132.       (let* ((vc pcs-local-var-count)    ; save
  133.          (vf pcs-verbose-flag)
  134.          (ef pcs-error-flag)
  135.          (bo pcs-binary-output)
  136.          (gensym-string (access string (procedure-environment gensym)))
  137.          (gensym-counter (access counter (procedure-environment gensym)))
  138.          (result (pcs-assembler (pcs-compile-to-AL exp))))
  139.         (set! pcs-local-var-count vc)    ; restore
  140.         (set! pcs-verbose-flag vf)
  141.         (set! pcs-error-flag ef)
  142.         (set! pcs-binary-output bo)
  143.         (set! (access string (procedure-environment gensym)) gensym-string)
  144.         (set! (access counter (procedure-environment gensym)) gensym-counter)
  145.         (pcs-clear-registers)
  146.         result)))
  147.       (%set-global-environment ge))
  148.  
  149. (define pcs-compile-to-AL                ; PCS-COMPILE-TO-AL
  150.   (lambda (exp)
  151.     (set! pcs-local-var-count 0)
  152.     (set! pcs-error-flag #F)
  153.     (set! pcs-binary-output #T)
  154.     (set! pcs-verbose-flag #F)
  155.     (let ((t1 (pcs-macro-expand exp)))
  156.       (if pcs-error-flag
  157.           (error "[Compilation terminated because of errors]")
  158.           (begin
  159.             (set! exp '())                          ; for GC
  160.             (pcs-clear-registers)
  161.             (let ((t2 (pcs-simplify t1)))
  162.               (pcs-closure-analysis t2)
  163.               (let ((t3 (pcs-gencode t2)))
  164.                 (set! t2 '())                               ; for GC
  165.                 (pcs-clear-registers)
  166.                 (let ((t4 (pcs-postgen t3)))
  167.                   (pcs-clear-registers)
  168.                   t4))))))))
  169.  
  170. (define pcs-execute-AL                    ; PCS-EXECUTE-AL
  171.   (lambda (al)
  172.     (let ((t1 (pcs-assembler al)))
  173.       (pcs-clear-registers)
  174.       (%execute t1))))
  175.  
  176. (define optimize!                    ; OPTIMIZE!
  177.   (lambda args
  178.     (let ((flag (or (null? args)(car args))))
  179.       (set! pcs-permit-peep-1 flag)
  180.       (set! pcs-permit-peep-2 flag))))
  181.  
  182.  
  183. ;; Syntax Checking Functions
  184. ;
  185. ; These functions may be used by macros and other syntax transformers
  186. ; to help find violations of Scheme syntax rules.  Note that these
  187. ; check only the syntax, not semantics, of the program fragments they
  188. ; are defined for.  It is the caller's responsibility, for example, to
  189. ; verify that all of the identifiers bound in a LETREC are distinct.
  190. ; PCS-CHK-PAIRS can't do so, because it is called to verify pairs for
  191. ; both LETREC and LET*.
  192.  
  193. (define pcs-chk-id                    ; PCS-CHK-ID
  194.   (lambda (e y)
  195.     (when (not (symbol? y))
  196.           (syntax-error "Invalid identifier in expression" y e))))
  197.  
  198. (define (pcs-chk-length= e y n)                ; PCS-CHK-LENGTH=
  199.   (cond ((and (null? y)(zero? n))
  200.          '())
  201.         ((null? y)
  202.          (syntax-error "Expression has too few subexpressions" e))
  203.         ((atom? y)
  204.          (syntax-error (if (atom? e)
  205.                            "List expected"
  206.                            "Expression ends with `dotted' atom")
  207.                        e))
  208.         ((zero? n)
  209.          (syntax-error "Expression has too many subexpressions" e))
  210.         (else
  211.           (pcs-chk-length= e (cdr y) (sub1 n)))))
  212.  
  213. (define (pcs-chk-length>= e y n)            ; PCS-CHK-LENGTH>=
  214.   (cond ((and (null? y)( < n 1))
  215.          '())
  216.         ((atom? y)
  217.          (pcs-chk-length= e y -1))
  218.         (else
  219.           (pcs-chk-length>= e (cdr y) (sub1 n)))))
  220.  
  221. (define (pcs-chk-bvl e bvl dot-ok?)         ; PCS-CHK-BVL
  222.   (letrec ((oops
  223.              (lambda () (syntax-error "Invalid identifier list" e))))
  224.     (cond ((atom? bvl)
  225.            (or (null? bvl)(and dot-ok? (pcs-chk-bvar bvl))
  226.                (oops)))
  227.           ((pcs-chk-bvar (car bvl))
  228.            (pcs-chk-bvl e (cdr bvl) dot-ok?))
  229.           (else
  230.             (oops)))))
  231.  
  232. (define (pcs-chk-pairs e pairs)                ; PCS-CHK-PAIRS
  233.   (letrec ((oops
  234.              (lambda () (syntax-error "Invalid pair binding list" e))))
  235.     (if (atom? pairs)
  236.         (or (null? pairs)
  237.             (oops))
  238.         (let ((pr (car pairs)))
  239.           (if (or (atom? pr)
  240.                   (not (pcs-chk-bvar (car pr)))
  241.                   (atom? (cdr pr))
  242.                   (not (null? (cddr pr))))
  243.               (oops)
  244.               (pcs-chk-pairs e (cdr pairs)))))))
  245.  
  246.  
  247. (define pcs-chk-bvar                    ; PCS-CHK-BVAR
  248.   (lambda (id)
  249.     (if (or (not (symbol? id))
  250.             (getprop id 'PCS*MACRO)
  251.             (memq id '(QUOTE LAMBDA IF SET!
  252.                              BEGIN LETREC DEFINE)))
  253.     (syntax-error "Invalid bound variable name" id)
  254.         #T)))
  255.  
  256. ; EXPAND, EXPAND-MACRO and EXPAND-MACRO-1 expand macro calls. EXPAND-MACRO
  257. ; and EXPAND-MACRO-1 only expand the outer-level form and leave sub-forms 
  258. ; alone.  EXPAND-MACRO-1 does so only once, while EXPAND-MACRO does so 
  259. ; repeatedly until there is no change. EXPAND expands form and all subforms
  260. ; completely.
  261.  
  262. (define expand-macro                    ; EXPAND-MACRO
  263.   (lambda (exp)
  264.     (let ((expansion (expand-macro-1 exp)))
  265.       (if (or (atom? exp) (equal? expansion exp))
  266.       expansion
  267.       (expand-macro expansion)))))
  268.  
  269. (define expand-macro-1                    ; EXPAND-MACRO-1
  270.   (lambda (x)
  271.     (cond ((symbol? x)
  272.        (let ((entry (getprop x 'PCS*MACRO)))
  273.          (cond ((null? entry) x)
  274.            ((pair? entry) (if (eq? (car entry) 'ALIAS)
  275.                       (cdr entry)))
  276.            ((procedure? entry) (entry x)))))
  277.       ((pair? x)
  278.        (let* ((f  (car x))
  279.           (ef (if (pair? f) (expand-macro f) f))
  280.           (a  (cdr x)))
  281.          (if (symbol? ef)
  282.                  (let ((macfun (getprop ef 'PCS*MACRO)))
  283.                    (cond ((null? macfun)
  284.                           (cons ef a))
  285.                          ((pair? macfun)
  286.                           (cons (cdr macfun) a))
  287.                          (else
  288.                            (macfun (cons ef a)))))
  289.                  (cons ef a))))
  290.       (else x))))
  291.  
  292. (define expand                        ; EXPAND
  293.   (letrec ((expand-item
  294.              (lambda (item)
  295.                (if (pair? item) (expand item) item))))
  296.     (lambda (exp)
  297.       (let ((expansion (expand-macro exp)))
  298.         (map expand-item expansion)))))
  299.  
  300. ;
  301. ; Set up EDWIN so that it may be loaded into its own environment
  302. ;
  303.  
  304. (define initiate-edwin                    ; INITIATE-EDWIN
  305.   (lambda ()
  306.     (unbind 'edwin user-global-environment)
  307.     (set! (access edwin-environment user-global-environment)
  308.       (make-hashed-environment))
  309.     (%reify! edwin-environment 0 user-initial-environment)
  310.     (let ((saved-env (%set-global-environment edwin-environment)))
  311.       (load (%system-file-name "edwin.fsl"))
  312.       (%set-global-environment saved-env))
  313.     (edwin)
  314.   ))
  315.  
  316. (define edwin initiate-edwin)                ; EDWIN
  317.  
  318. ;
  319. ; Set up compiler-related global variables
  320. ;
  321.  
  322. (BEGIN
  323.  (define %pcs-stl-debug-flag #F)
  324.  (define %pcs-stl-history    '(%PCS-STL-HISTORY))  ; getprop tag
  325.  (define pcs-local-var-count       0)
  326.  (define pcs-integrate-integrables  #T)
  327.  (define pcs-integrate-primitives   #T)
  328.  (define pcs-integrate-define       #T)
  329.  (define pcs-debug-mode           #F)    ; debug mode OFF
  330.  (define pcs-permit-peep-1       #T)    ; optimization ON
  331.  (define pcs-permit-peep-2       #T)
  332.  (define pcs-verbose-flag       #F)
  333.  (define pcs-display-warnings       #T)
  334.  (define pme=   '())
  335.  (define psimp= '())
  336.  (define pcg=   '())
  337.  (define ppeep= '())
  338.  (define pasm=  '())
  339. )
  340.  
  341. ; Evaluation
  342.  
  343. ; EVAL is part interpreter, but calls the compiler for complicated
  344. ; expressions.  In particular, it does not do any bindings
  345. ; interpretively, since they would have to be first-class
  346. ; environments and the compiler might be able to do better.
  347.  
  348. (define eval
  349.   (letrec
  350.     ((eval-exp
  351.        (lambda (xx env)
  352.          (let ((x (expand-macro xx)))
  353.            (if (pair? x)
  354.                (case (car x)
  355.                  ((QUOTE)        (eval-quote x env))
  356.                  ((IF)         (eval-if x env))
  357.                  ((SET!)        (eval-set! x env))
  358.                  ((DEFINE)        (eval-define x env))
  359.                  ((BEGIN)        (eval-begin x env))
  360.                  ((LET
  361.             LET*
  362.             LETREC
  363.             LAMBDA )        (eval-compile x env))
  364.                  ((%%GET-FLUID%%)    (eval-fluid x env))
  365.                  ((%%SET-FLUID%%)    (eval-set-fluid! x env))
  366.                  ((THE-ENVIRONMENT)    env)
  367.                  ((PCS-CODE-BLOCK)    (eval-execute x env))
  368.                  ((PCS-INLINE-BLOCK)    (eval-execute x env))
  369.                  (else         (eval-application x env)))
  370.                (eval-atom x env)))))
  371.      
  372.      (lookup-binding                    ; LOOKUP-BINDING
  373.        (lambda (sym)
  374.          ; The following is the object code to lookup/fetch
  375.          ; the binding of sym. It must be passed to %execute with
  376.          ; the desired environment.
  377.          (list 'pcs-code-block 1 4 (list sym)
  378.                '( 7 4 0       ; Ld-global r1,sym
  379.                     59))))       ; exit
  380.      
  381.      (eval-atom                    ; EVAL-ATOM
  382.        (lambda (x env)
  383.          (cond ((not (symbol? x)) x)
  384.                ((memq x '(#T #F #!TRUE #!FALSE #!UNASSIGNED)) x)
  385.                (else (or (lookup-integrable x env)
  386.              (eval-execute (lookup-binding x) env))))))
  387.      
  388.      (lookup-integrable
  389.        (lambda (x env)
  390.          (let ((info (getprop x 'PCS*PRIMOP-HANDLER)))
  391.            (and info
  392.                 (pair? info)
  393.                 (eval-exp (cdr info) env)))))
  394.      
  395.      (eval-quote                    ; EVAL-QUOTE
  396.        (lambda (x env)
  397.          (pcs-chk-length= x x 2)
  398.          (cadr x)))
  399.      
  400.      (eval-id-error
  401.        (lambda (err caller env)
  402.          (syntax-error
  403.            (string-append "Invalid identifier for " caller ": ") err)))
  404.      
  405.      
  406.      (eval-if                     ; EVAL-IF
  407.        (lambda (x env)
  408.          (if (or (atom? (cdr x))    ; No Pred
  409.                  (atom? (cddr x))    ; No Then
  410.                  (pair? (cdddr x)))    ; has ELSE
  411.          (pcs-chk-length= x x 4)
  412.          (pcs-chk-length= x x 3))
  413.          (cond ((eval-exp (cadr x) env)
  414.                 (eval-exp (caddr x) env))
  415.                ((pair? (cdddr x))
  416.                 (eval-exp (cadddr x) env))
  417.                (else
  418.          #F))))
  419.      
  420.      
  421.      (set-var-value                    ; SET-VAR-VALUE
  422.        (lambda (sym value)
  423.          ; The following is the object code code to set the value
  424.          ; of a variable. It must be passed to %execute with the
  425.          ; desired environment.
  426.          (list 'pcs-code-block 2 7 (list sym value)
  427.                '( 1 4 1        ; Load r1, value
  428.                     15 4 0    ; St-glob-env r1,sym
  429.                     59))))    ; exit
  430.      
  431.      (eval-set!                    ; EVAL-SET!
  432.        (lambda (x env)
  433.          (pcs-chk-length= x x 3)
  434.          (let* ((id    (cadr x))
  435.                 (var    (expand-macro id))
  436.                 (value (eval-exp (caddr x) env)))
  437.            (cond ((not (pair? var))
  438.                   (cond ((or (not (symbol? var))
  439.                              (not (eq? var (expand-macro var))))
  440.                          (eval-id-error var "SET!" env))
  441.                         ((getprop var 'PCS*PRIMOP-HANDLER)
  442.                          ; this is for primitives and define-integrables
  443.                          (eval-compile x env))
  444.                         (else
  445.               (eval-execute (SET-VAR-VALUE var value) env))))
  446.                  (else
  447.            (eval-id-error var "SET!" env))))))
  448.      
  449.      (def-var                       ; DEF-VAR
  450.        (lambda (sym value)
  451.          ; The following is the object code code to define a variable
  452.          ; in a given environment. It must be passed to %execute with the
  453.          ; desired environment.
  454.          (list 'pcs-code-block 2 7 (list sym value)
  455.                '( 1  4 1        ; Load r1, value
  456.                   31 4 0    ; define!  value,sym
  457.                   59))))    ; exit
  458.      
  459.      (eval-define                    ; EVAL-DEFINE
  460.        (lambda (x env)
  461.          (pcs-chk-length>= x x 3)
  462.          (if (and (pair? (caddr x))
  463.                   (memq (caaddr x) '(LAMBDA NAMED-LAMBDA)))
  464.              (eval-compile x env)
  465.              ;else
  466.              (let* ((id      (cadr x))
  467.                     (var   (expand-macro id))
  468.                     (value (eval-exp (caddr x) env)))
  469.                (cond ((not (pair? var))
  470.                       (cond ((or (not (symbol? var))
  471.                                  (not (eq? var (expand-macro var))))
  472.                              (eval-id-error var "DEFINE" env))
  473.                             ((getprop var 'PCS*PRIMOP-HANDLER)
  474.                              ; this is for primitives and define-integrables
  475.                              (eval-compile x env))
  476.                             (else
  477.                   (eval-execute (DEF-VAR var value) env)
  478.                               id)))
  479.                      (else
  480.                        (eval-id-error var "DEFINE" env)))))))
  481.      
  482.      
  483.      (eval-begin                    ; EVAL-BEGIN
  484.        (lambda (x env)
  485.          (pcs-chk-length>= x x 1)
  486.          (let loop ((x (cdr x)))
  487.            (if (null? (cdr x))
  488.                (eval-exp (car x) env)
  489.                (begin
  490.                  (eval-exp (car x) env)
  491.                  (loop (cdr x)))))))
  492.      
  493.      (lookup-fluid                    ; LOOKUP-FLUID
  494.        (lambda (sym)
  495.          ; The following is the object code to lookup/fetch the
  496.          ; fluid binding of sym. It must be passed to %execute with
  497.          ; the desired environment.
  498.          (list 'pcs-code-block 1 4 (list sym)
  499.                '( 8 4 0       ; Ld_fl r1,sym
  500.                     59))))       ; exit
  501.      
  502.      (eval-fluid                    ; EVAL-FLUID
  503.        (lambda (x env)
  504.          (pcs-chk-length= x x 2)
  505.          (eval-execute (lookup-fluid (eval-exp (cadr x) env)) env)))
  506.      
  507.      (set-fluid-var                    ; SET-FLUID-VAR
  508.        (lambda (sym value)
  509.          ; The following is the object code to set the value of a
  510.          ; fluid variable. It must be passed to %execute with the
  511.          ; desired environment.
  512.          (list 'pcs-code-block 2 7 (list sym value)
  513.                '( 1 4 1        ; Load  r1, value
  514.                     16 4 0    ; St-fl r1,sym
  515.                     59))))    ; exit
  516.      
  517.      (eval-set-fluid!                 ; EVAL-SET-FLUID!
  518.        (lambda (x env)
  519.          (pcs-chk-length>= x x 2)
  520.          (let ((sym  (eval-exp (cadr x) env))
  521.                (val (eval-exp (caddr x) env)))
  522.            (pcs-chk-id x sym)
  523.            (eval-execute (set-fluid-var sym val) env))))
  524.      
  525.      (eval-application                ; EVAL-APPLICATION
  526.        (lambda (x env)
  527.          (pcs-chk-length>= x x 1)
  528.          (let ((proc (eval-exp (car x) env)))
  529.            (when (not (or (procedure? proc)
  530.                           (and (pair? proc)
  531.                                (eq? (car proc) 'LAMBDA))))
  532.                  (error-procedure "Attempt to call a non-procedural object"
  533.                                   (cons proc (cdr x))
  534.                                   env))
  535.            (let ((args (eval-args (cdr x) env)))
  536.              (let* ((saved-env (%set-global-environment env))
  537.                     (result (apply proc args)))
  538.                (%set-global-environment saved-env)
  539.                result)))))
  540.      
  541.      (eval-args                    ; EVAL-ARGS
  542.        (lambda (x env)
  543.          (if (null? x)
  544.              '()
  545.              (cons (eval-exp  (car x) env)
  546.                    (eval-args (cdr x) env)))))
  547.      
  548.      (eval-compile                    ; EVAL-COMPILE
  549.        (lambda (x env)
  550.          (eval-execute (compile x) env)))
  551.      
  552.      (eval-execute                    ; EVAL-EXECUTE
  553.        (lambda (x env)
  554.          (let* ((saved-env (%set-global-environment env))
  555.                 (result (%execute x)))
  556.            (%set-global-environment saved-env)
  557.            result)))
  558.      
  559.      ) ; letrec vars
  560.     
  561.     (lambda (exp . rest)
  562.       (let* ((env (cond ((null? rest)
  563.                          (let ((e (%set-global-environment
  564.                                     user-initial-environment)))
  565.                            (%set-global-environment e)
  566.                            e))
  567.             ((not (environment? (car rest)))
  568.              (%error-invalid-operand 'EVAL (car rest)))
  569.             (else
  570.                           (car rest))))
  571.          (result (eval-exp exp env)))
  572.         result))))
  573.        
  574. (define (inline-lambda count arg)
  575.   (%execute `(pcs-code-block 1 15 (,arg)
  576.                              (0 4 0    ; load    R1, '()
  577.                               60 4 1 0 ,(if (pair? count) (length count) count)
  578.                     ; close    R1, |, count
  579.                               59    ; exit
  580.                               1 248 0    ; load-const    R62, arg
  581.                               58 248    ; %execute    R62
  582.                               59))))    ; exit
  583.  
  584.